perm filename PCROSS.PAS[PAS,SYS]2 blob
sn#459959 filedate 1979-07-21 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00017 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*things yet to do:
C00007 00003 (*description and history*)
C00011 00004 (*valid switches*)
C00016 00005 (*global declarations*)
C00040 00006 (*INITPROCEDURES*) (*reinitialize*) (*getcounts*) (*initialize*)
C00053 00007 (*get←directives[*) (*SETSWITCH*) (*]*)
C00063 00008 (*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
C00065 00009 (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
C00075 00010 (*SCANNER:*) (*INSYMBOL[*) (*READBUFFER[*) (*readline]*) (*RESWORD*) (*FINDNAME*) (*insertcall*)
C00086 00011 (*parenthese*) (*docomment[*) (*options]*) (*skip_e_directory*)
C00095 00012 (*] INSYMBOL*)
C00103 00013 (*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
C00108 00014 (*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
C00120 00015 (*]BLOCK*)
C00127 00016 (*PRINT←XREF←LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
C00137 00017 (*MAIN PROGRAM*)
C00139 ENDMK
C⊗;
(*things yet to do:
version 3 should not play with crosslist.
(careful: no nested version stuff).
version 3 → PFORM
test #name, =name.
get the compiler to work on =name, #name.
*)
(*$T-,r64,d- *) (*title page*)
(********************************************************************************
*
* p c r o s s
* ***********
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1976,
* H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG-13
* GERMANY
*
*
* pcross is a mixture of a pretty-printer and a cross-referencer
* for source programs written in pascal. it is compatible with
* the lots pascal and passgo compilers. the version numbers match
* each other.
*
* This source contains conditionally-compiled sections, supported by the
* /VERSION switch, as implemented in the LOTS PASCAL/PASSGO compilers.
* The meanings of the switch values are:
*
* 1: Full PCROSS at LOTS
* 2: PCREF (No NEWSOURCE) at LOTS
* 3: Full PCROSS at SAIL
* 4: PCREF at SAIL
*
(********************************************************************************
(* CONTENTS *)
(* 2*) (*DECLARATIONS*)
(* 3*) (*INITPROCEDURES*)
(* 4*) (*get←directives[*) (*SETSWITCH*) (*]*)
(* 5*) (*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
(* 6*) (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
(* 7*) (*SCANNER:*) (*INSYMBOL[*) (*READBUFFER*) (*RESWORD*) (*FINDNAME*) (*PARENTHESE*) (*DOCOMMENT*) (*]*)
(* 8*) (*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
(* 9*) (*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
(*10*) (*]BLOCK*)
(*11*) (*PRINT←XREF←LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
(*12*) (*MAIN PROGRAM*)
(*description and history*)
(**********************************************************************
*
*
* PROGRAM WHICH CREATES A CROSS REFERENCE LISTING
* AND A NEW, REFORMATTED VERSION OF A PASCAL PROGRAM.
*
* INPUT: PASCAL SOURCE FILE.
* OUTPUT: NEW REFORMATTED SOURCE FILE AND
* CROSS-REFERENCE LISTING.
*
* FROM AN ORIGINAL CROSS-REFERENCE PROCESSOR WRITTEN BY
* MANUEL MALL, UNIVERSITY OF HAMBURG. (1974)
*
* DATE UNKNOWN. LARRY PAULSON (STANFORD).
* + MAKE THE FILES OF TYPE TEXT
* + NOT AS MANY FORCED NEWLINES.
* + THE REPORT ON PROCEDURE CALLS WAS CANCELLED.
*
* MAR-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + A NEW SET OF SWITCH OPTIONS.
* + SOME NEW ERRORS ARE REPORTED.
*
* JUL-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + ACCEPT NON-STANDARD COMMENT CONVENTIONS. STANDARIZE THEM.
* + IMPROVE THE CROSS REFERENCE LISTING.
* + LISTING OF PROC-FUNC CALL NESTING.
* + REPORT THE LINE NUMBERS OF BEGIN AND END OF BODY OF PROCEDURES.
*
* SEE THE PROCEDURE get←directives FOR THE AVAILABLE SWITCHES.
* DEC-78. ARMANDO R. RODRIGUEZ (STANFORD)
* + SPEED UP AND CLEANNING OF THE CODE.
* + FIX SMALL BUGS.
*
* MAR-79. ARMANDO R. RODRIGUEZ
* + IMPLEMENT STATEMENT COUNTS.
*
*
* jul-79. armando r. rodriguez.
* + implement a wider /version switch system
* + implement the (*$#NAME,=NAME Switches
* + Create CREF, no NEWsource file.
* + adapt it for the lineprinter at sail.
*
* THINGS TO BE FIXED, OR DOCUMENTED:
* + IF THERE ARE TWO PROCS WITH ONE NAME, IT MIXES THEM.
* + IF A PROC NAME IS USED AS A VAR LATER, IT WILL BE SEEN
* AS A PROC FOR CALL-NESTING.
* + MAKE IT SMART ENOUGH TO AVOID CREATING STRUCTURES
* THAT WON'T BE USED, WHEN CROSS IS NOT 15.
*
*
(**********************************************************************)
(*valid switches*)
(*---------------------------------------------------------------------
!
! VALID SWITCHES ARE: BRACKETS INDICATE OPTIONAL.
! <N> STANDS FOR AN INTEGER NUMBER.
! (defaults in parens are at sail) <L> STANDS FOR A LETTER.
!
! SWITCH MEANING DEFAULT.
!
! FILES.
! /[NO]NEW WRITTING OF THE NEWSOURCE FILE ON
! /[NO]CROSS[:<N>] WRITTING OF THE CROSSLIST FILE. ON,15
! <N> IS THE SUM OF:
! 1 SOURCE PROGRAM LISTING
! 2 LISTING OF IDENTIFIERS
! 4 LISTING OF PROC-FUNC
! DECLARATION NESTING.
! 8 LISTING OF PROC-FUNC CALL NESTING.
! /VERSION:<N> BEHAVE AS IF CONDITIONALLY COMPILING %<N>
! COMMENTS. -1
!
! PAGE AND LINE FORMAT
! /width:<n> maximum line length in crosslist 132 (120)
! /INDENT:<N> INDENTATION BETWEEN LEVELS. 4
! /INCREMENT:<N> LINE NUMBER INCREMENT 100
! /[NO]DOTS PUT AS A GUIDE A DOTTED LINE AT THE LEFT
! MARGIN EVERY FIFTH LINE ON
! /lines:<n> number of lines per page 57 (51)
!
! STATEMENT FORMAT
! /BEGIN:[-]<N> IF THE [-] IS NOT THERE, THE CONTENTS OF A
! BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
! IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
! BUT THE BEGIN AND END STATEMENTS WILL BE
! EXDENTED N SPACES. 0
! /[NO]FORCE FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
! AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.) OFF
!
! UPPER AND LOWER CASE
! NOTE: THE POSSIBLE VALUES FOR <L> ARE:
! U MEANS UPPER CASE
! L MEANS LOWER CASE.
!
! /RES:<L> CASE USED FOR RESERVED WORDS. U
! /NONRES:<L> SAME FOR NON-RESERVED WORDS. L
! /COMM:<L> SAME FOR COMMENTS. L (U)
! /STR:<L> SAME FOR STRINGS. U
! /CASE:<L> RESETS ALL THE DEFAULTS TO <L>. OFF
!
+--------------------------------------------------------------------*)
(*global declarations*)
%13
PROGRAM pform ;
\
%24
program pcref;
\
CONST
%1 version = 'Pform/LOTS 1.0 10-jul-79'; \
%2 version = 'pcref/lots 1.0 10-jul-79'; \
%3 version = 'Pform/sail 1.0 10-jul-79'; \
%4 version = 'pcref/sail 1.0 10-jul-79'; \
verlength = 10;
%12 stdmaxline = 57; \ (*MAXIMUM NUMBER OF LINES PER PAGE, IGNORING HEADER*)
%12 maxcrossch = 132; \
%12 margin = 16; \
%12 linnumsize = 5; \
%3 stdmaxline = 51; \
%4 stdmaxline = maxint; \
%34 maxcrossch = 120; \
%34 margin = 14; \
%34 linnumsize = 3; \
countersize = 8; (*field size for the statement count value*)
max←line←count = 7777B; (*LIMIT OF LINES/EDIT-PAGE*)
max←page←count = 77B; (*LIMIT OF EDIT-PAGES*)
(* MAX←LINE←COUNT AND MAX←PAGE←COUNT SHOULD NOT NEED MORE THAN 18 BITS TOTAL*)
ht = 11B; (*ascii tab*)
ff = 14B; (*ASCII FORM FEED*)
cr = 15B; (*ASCII CARRIAGE RETURN*)
blanks = ' '; (*FOR EDITING PURPOSES*)
%12 dots = ' . . . + . . . + . . . + . . . + . . . + . . . + . . . +'; \
%34 dots = ' . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . +'; \
TYPE
pack6 = PACKED ARRAY[1..6] OF char;
pack9 = PACKED ARRAY[1..9] OF char;
errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit,
missgrpar,missgquote,missgmain,missgpoint,linetoolong,illversion,
missgrbrack,missguntil);
lineptrty = ↑line;
listptrty = ↑list;
procstructy = ↑procstruc;
calledty = ↑called;
linenrty = 0..max←line←count;
pagenrty = 0..max←page←count;
symbol = (labelsy,constsy,typesy,varsy,programsy, (*DECSYM*)
functionsy,proceduresy,initprocsy, (*PROSYM*)
endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*ENDSYMBOLS*)
beginsy,casesy,loopsy,repeatsy,ifsy, (*BEGSYM*)
recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*DELIMITER*));
line = PACKED RECORD
(*DESCRIPTION OF THE LINE NUMBER*)
linenr : linenrty; (*LINE NUMBER*)
pagenr : pagenrty; (*PAGE NUMBER*)
contlink : lineptrty; (*NEXT LINE NUMBER RECORD*)
declflag: char; (*'D' IF DECLARATION, 'M' IF MULTIPLE OCCURRENCE,
BLANK OTHERWISE*)
END;
list = PACKED RECORD
(*DESCRIPTION OF IDENTIFIERS*)
name : alfa; (*NAME OF THE IDENTIFIER*)
llink , (*LEFT SUCCESSOR IN TREE*)
rlink : listptrty; (*RIGHT SUCCESSOR IN TREE*)
first , (*POINTER TO FIRST LINE NUMBER RECORD*)
last : lineptrty; (*POINTER TO LAST LINE NUMBER RECORD*)
externflag: char; (*'E' IF EXTERNAL, 'F' IF FORWARD,
'D' IF TWO PROCS WITH THE SAME NAME, BLANK OTHERWISE*)
profunflag : char; (*'P' IF PROCEDURE NAME, 'F' IF FUNCTION, BLANK OTHERWISE*)
procdata: procstructy;
END;
procstruc = PACKED RECORD
(*DESCRIPTION OF THE PROCEDURE NESTING*)
procname : listptrty; (*POINTER TO THE APPROPRIATE IDENTIFIER*)
nextproc : procstructy; (*POINTER TO THE NEXT ELEMENT*)
linenr, (*LINE NUMBER OF THE PROCEDURE DEFINITION*)
begline, (*LINE NUMBER OF THE BEGIN STATEMENT*)
endline: linenrty; (*LINENUMBER OF THE END STATEMENT*)
pagenr , (*PAGE NUMBER OF THE PROCEDURE DEFINITION*)
begpage, (*PAGE NUMBER OF THE BEGIN STATEMENT*)
endpage, (*PAGE NUMBER OF THE END STATEMENT*)
proclevel: pagenrty; (*NESTING DEPTH OF THE PROCEDURE*)
firstcall: calledty; (*LIST OF PROCEDURES CALLED BY THIS ONE*)
printed: boolean; (*TO AVOID LOOPS IN THE CALL-NEST LIST*)
END;
called = PACKED RECORD
nextcall : calledty;
whom : procstructy;
END;
VAR
(* (*INPUT CONTROL*)
(* (***************)
bufflen, (*LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER*)
buffmark, (*LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER*)
bufferptr, (*POINTER TO THE NEXT CHARACTER IN THE BUFFER*)
syleng, (*LENGTH OF THE LAST READ IDENTIFIER OR LABEL*)
(* (*NESTING AND MATCHING CONTROL*)
(* (******************************)
bmarknr, (*NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.*)
emarknr, (*NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.*)
level, (*NESTING DEPTH OF THE CURRENT PROCEDURE*)
variant←level, (*NESTING DEPTH OF VARIANTS*)
blocknr, (*COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'*)
errcount, (*COUNTS THE ERRORS ENCOUNTERED*)
(* (*FORMATTING*)
(* (************)
increment, (*LINE NUMBER INCREMENT*)
indentbegin, (*INDENTATION AFTER A BEGIN*)
begexd, (*EXDENTATION FOR BEGIN-END PAIRS*)
feed, (*INDENTATION BY PROCEDURES AND BLOCKS*)
spaces, (*INDENTATION FOR THE CURRENT LINE*)
lastspaces, (*ONE-TIME OVERRIDING VALUE FOR SPACES*)
goodversion, (*KEEPS THE VALUE OF THE VERSION OPTION*)
countline, (*NEXT LINE FOR STATEMENT COUNTER*)
countpage, (*PAGE OF NEXT LINE FOR STATEMENT COUNTER*)
counttimes, (*STATEMENT COUNT OF COUNTLINE/COUNTPAGE*)
maxcounttimes, (*COUNT OF THE LINE WITH HIGHER COUNTTIMES*)
maxcountline, (*LINE FOR MAXCOUNTTIMES*)
maxcountpage, (*PAGE FOR MAXCOUNTTIMES*)
pagecnt, (*COUNTS THE FILE PAGES*)
pagecnt2, (*COUNTS THE PRINT PAGES PER FILE PAGE*)
maxinc, (*GREATEST ALLOWABLE LINE NUMBER*)
maxline, (*number of lines per page*)
maxch, (*maximum length of source line in CROSSLIST*)
reallincnt, (*COUNTS THE LINES PER PRINT PAGE*)
line500, (*to give a tty message every 500 lines*)
sourceline, (*to match SOS lines*)
sourcepage,
linecnt : integer; (*COUNTS THE LINES PER FILE PAGE*)
procstrucdata : RECORD
(*NEXT PROCEDURE TO BE PUT IN NESTING LIST*)
exists : boolean;
item : procstruc;
END;
lower : ARRAY [ascii] OF ascii; (*TO MAP UPPER TO LOWER CASE IF DESIRED*)
buffer : ARRAY [-1..302] OF ascii; (*INPUT BUFFER*)
(* BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT*)
tabs: ARRAY [1:17] OF ascii; (*A STRING OF TABS FOR FORMATTING*)
linenb : PACKED ARRAY [1..5] OF char; (*SOS-LINE NUMBER*)
date←text,time←text: alfa; (*HEADING DATE AND TIME*)
curprocname, (*NAME OF THE CURRENT PROCEDURE/FUNCTION, FOR THE HEADER*)
prog←name, (*NAME OF CURRENT PROGRAM*)
sy : alfa; (*LAST SYMBOL READ*)
syty : symbol; (*TYPE OF THE LAST SYMBOL READ*)
marksyty, (*type of the symbol before the last if*)
prevsyty: symbol; (*type of the previous symbol*)
(* (*version system*)
(* (****************)
incondcomp: boolean;
whichcond: char;
nameversion: packed array[1..5] of char;
(* (*SWITCHES*)
(* (**********)
%13 renewing, \ (*SET IF THE NEWLSOURCE FILE IS BEING WRITTEN*)
crossing, (*SET IF THE CROSSLIST FILE IS BEING WRITEN*)
refing, (*SET IF THE REFERENCES WILL BE PRINTED*)
decnesting, (*SET IF THE PRO-FUNC DECLARATION LISTING WILL BE PRINTED*)
callnesting, (*SET IF THE PRO-FUNC CALL NESTING WILL BE PRINTED*)
dotting, (*SET IF DOTED LINES WILL BE PRINTED AT LEFT MARGIN*)
forcing, (*SET IF THEN, ELSE, DO, REPEAT WILL FORCE NEWLINE*)
rescase, (*SET IF RESERVED WORDS WILL UPSHIFT*)
nonrcase, (*SET IF NONRESERVED WORDS WILL UPSHIFT*)
comcase, (*SET IF COMMENTS WILL UPSHIFT*)
strcase, (*SET IF STRINGS WILL UPSHIFT*)
thendo, (*SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED*)
anyversion, (*SET IF GOODVERSION > 9*)
counting, (*SET IF A .KNT EXISTS, FOR STATEMENT COUNTS*)
(* (*OTHER CONTROLS*)
(* (****************)
elsehere, (*set when counting, forcing, and an else is here*)
fwddecl, (*SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'*)
oldspaces, (*SET WHEN LASTSPACES SHOULD BE USED*)
eoline, (*SET AT END ON INPUT LINE*)
gotoinline, (*SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE*)
declaring, (*SET WHILE PARSING DECLARATIONS*)
firstpage, (*TRUE BEFORE WRITTING ANYTHING*)
%34 skipping, (*true while skipping the e-directory*) \
programpresent, (*SET AFTER PROGRAM ENCOUNTERED*)
nobody, (*SET IF NO MAIN BODY IS FOUND*)
stmtpart, (*set if processing the statement part*)
eob : boolean; (*EOF-FLAG*)
errmsg : PACKED ARRAY[errkinds,1..40] OF char; (*ERROR MESSAGES*)
ch : ascii; (*LAST READ CHARACTER*)
bmarktext, (*CHARACTER FOR MARKING OF 'BEGIN' ETC.*)
emarktext: char; (*CHARACTER FOR MARKING OF 'END' ETC.*)
(* (*SETS*)
(* (******)
delsy : ARRAY [' '..'←'] OF symbol; (*TYPE ARRAY FOR DELIMITER CHARACTERS*)
resnum: ARRAY['A'..'['] OF integer; (*INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER*)
reslist : ARRAY [1..46] OF alfa; (*LIST OF THE RESERVED WORDS*)
ressy : ARRAY [1..46] OF symbol; (*TYPE ARRAY OF THE RESERVED WORDS*)
alphanum, (*CHARACTERS FROM 0..9 AND A..Z*)
digits : SET OF char; (*CHARACTERS FROM 0..9*)
openblocksym, (*symbols after which a basic block starts*)
relevantsym, (*START SYMBOLS FOR STATEMENTS AND PROCEDURES*)
prosym, (*ALL SYMBOLS WHICH BEGIN A PROCEDURE*)
decsym, (*ALL SYMBOLS WHICH BEGIN DECLARATIONS*)
begsym, (*ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS*)
endsym : SET OF symbol; (*ALL SYMBOLS WHICH TERMINATE STATEMENTS OR PROCEDURES*)
(* (*POINTERS AND FILES*)
(* (********************)
listptr, heapmark : listptrty; (*POINTER INTO THE BINARY TREE OF THE IDENTIFIER*)
firstname : ARRAY ['A'..'Z'] OF listptrty; (*POINTER TO THE ROOTS OF THE TREE*)
procstrucf, (*POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST*)
procstrucl : procstructy; (*POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST*)
workcall: calledty;
%13 new←name, \
countfilename, (*NAME OF THE STATEMENT COOUNTS FILE*)
link←name,
old←name, cross←name: pack9; (*USED TO GET THE PARAMETER FILES*)
%13 new←dev, \
old←dev,link←device,cross←dev:pack6;
%13 new←prot,new←ppn, \
old←prot,old←ppn,cross←prot,cross←ppn: integer;
%13 newfileid, \
programname,oldfileid,crossfileid: alfa;
%13 newsource, \
oldsource,crosslist: text; (*FILES PROCESSED BY THIS PROGRAM*)
countfile: FILE OF integer; (*FILE FOR STATEMENT COUNTS*)
(*INITPROCEDURES*) (*reinitialize*) (*getcounts*) (*initialize*)
INITPROCEDURE;
BEGIN (*CONSTANTS*)
eob := false;
%12 increment:=100; \
%12 feed:=4; \
%34 increment := 1; \
%34 feed := 3; \
indentbegin:=0;
begexd:=0;
goodversion := -1;
rescase:=true;
nonrcase:=false;
%12 comcase:=false; \
%34 comcase := true; \
strcase:=true;
%13 renewing:=true; \
crossing:=true;
refing:=false;
decnesting:=false;
callnesting:=false;
dotting:=true;
nobody := false;
anyversion := false;
%13 new←name:=' '; \
cross←name:=' ';
%13 programname:='Pform '; \
%24 programname := 'pcref '; \
oldfileid:='OLDSOURCE ';
%13 newfileid:='NEWSOURCE '; \
crossfileid:='CROSSLIST ';
END (*CONSTANTS*);
INITPROCEDURE;
BEGIN (*RESERVED WORDS*)
resnum['A'] := 1; resnum['B'] := 3; resnum['C'] := 4;
resnum['D'] := 6; resnum['E'] := 9; resnum['F'] := 13;
resnum['G'] := 18; resnum['H'] := 19; resnum['I'] := 19;
resnum['J'] := 22; resnum['K'] := 22; resnum['L'] := 22;
resnum['M'] := 24; resnum['N'] := 25; resnum['O'] := 27;
resnum['P'] := 30; resnum['Q'] := 33; resnum['R'] := 33;
resnum['S'] := 35; resnum['T'] := 36; resnum['U'] := 39;
resnum['V'] := 40; resnum['W'] := 41; resnum['X'] := 43;
resnum['Y'] := 43; resnum['Z'] := 43; resnum['['] := 43;
reslist[ 1] :='AND '; ressy [ 1] := othersy;
reslist[ 2] :='ARRAY '; ressy [ 2] := othersy;
reslist[ 3] :='BEGIN '; ressy [ 3] := beginsy;
reslist[ 4] :='CASE '; ressy [ 4] := casesy;
reslist[ 5] :='CONST '; ressy [ 5] := constsy;
reslist[ 6] :='DO '; ressy [ 6] := dosy;
reslist[ 7] :='DIV '; ressy [ 7] := othersy;
reslist[ 8] :='DOWNTO '; ressy [ 8] := othersy;
reslist[ 9] :='END '; ressy [ 9] := endsy;
reslist[10] :='ELSE '; ressy [10] := elsesy;
reslist[11] :='EXIT '; ressy [11] := exitsy;
reslist[12] :='EXTERN '; ressy [12] := externsy;
reslist[13] :='FOR '; ressy [13] := forsy;
reslist[14] :='FILE '; ressy [14] := othersy;
reslist[15] :='FORWARD '; ressy [15] := forwardsy;
reslist[16] :='FUNCTION '; ressy [16] := functionsy;
reslist[17] :='FORTRAN '; ressy [17] := externsy;
reslist[18] :='GOTO '; ressy [18] := gotosy;
reslist[19] :='IF '; ressy [19] := ifsy;
reslist[20] :='IN '; ressy [20] := othersy;
reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
reslist[22] :='LOOP '; ressy [22] := loopsy;
reslist[23] :='LABEL '; ressy [23] := labelsy;
reslist[24] :='MOD '; ressy [24] := othersy;
reslist[25] :='NOT '; ressy [25] := othersy;
reslist[26] :='NIL '; ressy [26] := othersy;
reslist[27] :='OR '; ressy [27] := othersy;
reslist[28] :='OF '; ressy [28] := ofsy;
reslist[29] :='OTHERS '; ressy [29] := otherssy;
reslist[30] :='PACKED '; ressy [30] := othersy;
reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
reslist[32] :='PROGRAM '; ressy [32] := programsy;
reslist[33] :='RECORD '; ressy [33] := recordsy;
reslist[34] :='REPEAT '; ressy [34] := repeatsy;
reslist[35] :='SET '; ressy [35] := othersy;
reslist[36] :='THEN '; ressy [36] := thensy;
reslist[37] :='TO '; ressy [37] := othersy;
reslist[38] :='TYPE '; ressy [38] := typesy;
reslist[39] :='UNTIL '; ressy [39] := untilsy;
reslist[40] :='VAR '; ressy [40] := varsy;
reslist[41] :='WHILE '; ressy [41] := whilesy;
reslist[42] :='WITH '; ressy [42] := othersy;
END (*RESERVED WORDS*);
INITPROCEDURE;
BEGIN (*SETS*)
digits := ['0'..'9'];
alphanum := ['0'..'9','A'..'Z'] (*LETTERS OR DIGITS*);
decsym := [labelsy,constsy,typesy,varsy,programsy];
prosym := [functionsy..initprocsy];
endsym := [functionsy..eobsy]; (*PROSYM OR ENDSYMBOLS*)
begsym := [beginsy..ifsy];
relevantsym := [labelsy..initprocsy (*DECSYM OR PROSYM*),beginsy,forwardsy,externsy,eobsy];
openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy]
END (*SETS*);
INITPROCEDURE;
BEGIN (*ERROR MESSAGES*)
errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
errmsg[missgend ] := 'MISSING ''END'' statement NUMBER ';
errmsg[missgthen ] := 'MISSING ''THEN'' FOR ''IF'' NUMBER ';
errmsg[missgof ] := 'MISSING ''OF'' IN ''CASE'' NUMBER ';
errmsg[missgexit ] := 'MISSING ''EXIT'' IN ''LOOP'' NUMBER ';
errmsg[missgrpar ] := 'MISSING RIGHT PARENTHESIS ';
errmsg[missgquote ] := 'MISSING CLOSING QUOTE ON THIS LINE ';
errmsg[missgmain ] := 'WARNING: THIS FILE HAS NO MAIN BODY ';
errmsg[missgpoint ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
errmsg[linetoolong ] := 'line too long. i''m gonna get confused. ';
errmsg[illversion ] := 'error in name-version option (# or =) ';
errmsg[missguntil ] := 'missing ''until'' for ''repeat'' number ';
errmsg[missgrbrack ] := 'missing right bracket ';
END (*ERROR MESSAGES*);
PROCEDURE reinitialize;
var
lch: char;
BEGIN (*REINITIALIZE*)
new(heapmark); (*THE HEAP IS DEALLOCATED AFTER EACH PROGRAM*)
workcall := NIL;
bufflen := 0; buffmark := 0;
bufferptr := 2; variant←level := 0; reallincnt:= maxline;
line500 := 0; linecnt :=0; pagecnt := 1;
pagecnt2 := 0; sourcepage := 1; sourceline := 0;
maxcountpage := 0; maxcountline := 0; maxcounttimes := 0;
blocknr := 0; level := 0; errcount := 0;
eoline := true; gotoinline := false; firstpage := true;
programpresent := false; procstrucdata.exists := false; oldspaces := false;
declaring := true; incondcomp := false; elsehere := false;
%skipping := false; \
bmarktext := ' '; emarktext := ' '; ch := ' ';
whichcond := ' ';
sy := blanks; prog←name := blanks;
date(date←text); time(time←text);
FOR lch := 'A' TO 'Z' DO
firstname [lch] := NIL;
new (firstname['M']);
listptr := firstname ['M'];
WITH firstname ['M']↑ DO
BEGIN
name := 'MAIN PROGM';
llink := NIL;
rlink := NIL;
profunflag := 'M';
new (first);
last := first;
WITH last↑ DO
BEGIN
linenr := 1;
pagenr:=1;
contlink := NIL;
END;
END;
new (procstrucf);
WITH procstrucf↑ DO
BEGIN
procname := firstname ['M'];
nextproc := NIL;
linenr := 1;
pagenr:=1;
proclevel:= 0;
firstcall := NIL;
END;
procstrucl := procstrucf;
curprocname := 'MAIN PROGM';
END (*REINITIALIZE*);
PROCEDURE getcounts;
BEGIN
IF eof(countfile) THEN
BEGIN
countline := 99999;
countpage := 99999;
END
ELSE
BEGIN
countpage := countfile↑;
get(countfile);
countline := countfile↑;
get(countfile);
counttimes := countfile↑;
get(countfile);
END;
END (*GETCOUNTS*);
PROCEDURE initialize;
var
i: integer;
BEGIN (*INITIALIZE*)
FOR ch := ' ' TO '←' DO
delsy [ch] := othersy;
delsy ['('] := lparent;
delsy [')'] := rparent;
delsy ['['] := lbracket;
delsy [']'] := rbracket;
delsy [';'] := semicolon;
delsy ['.'] := point;
delsy [':'] := colon;
delsy ['='] := eqlsy;
FOR i := -1 TO 201 DO
buffer [i] := ' ';
FOR i := 1 TO 17 DO
tabs [i] := chr (ht);
FOR ch := nul TO '@' DO
lower[ch] := ch;
FOR ch := 'A' TO 'Z' DO
lower[ch] := chr (ord(ch) + 40B);
FOR ch := '[' TO del DO
lower[ch] := ch;
reinitialize;
END (*INITIALIZE*);
(*get←directives[*) (*SETSWITCH*) (*]*)
PROCEDURE get←directives;
(* CHECKS THE PRESENCE OF SWITCHES WITH THE FILE NAMES. *)
VAR
brkchar: char;
try: integer;
fromtmp: boolean;
PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
VAR
i: integer;
BEGIN (*SETSWITCH*)
getoption(opt,i);
IF i=ord('L') THEN
switch:=false
ELSE
IF i=ord('U') THEN
switch:=true;
END (*SETSWITCH*);
BEGIN (*get←directives*)
%12
getparameter(oldsource,oldfileid,programname,true);
\
%34
askfilename(old_name,old_prot,old_ppn,old_dev,oldfileid,programname,false,fromtmp,brkchar);
startfile(oldsource,old_name,old_prot,old_ppn,old_dev,true,oldfileid,'pas');
\
getstatus(oldsource,old←name,old←prot,old←ppn,old←dev);
countfilename := old←name;
countfilename[7] := 'K';
countfilename[8] := 'N';
countfilename[9] := 'T';
reset(countfile,countfilename);
IF eof(countfile) THEN
reset (countfile,countfilename,old←prot,old←ppn,old←dev);
counting := NOT eof(countfile);
IF counting THEN
begin
forcing := true;
%13 renewing := false; \
%4
callnesting := false;
decnesting := false;
refing := false;
\
getcounts;
end;
%13
IF NOT option ('NONEW ') THEN
askfilename(new←name,new←prot,new←ppn,new←dev,newfileid,programname,false,fromtmp,brkchar);
\
IF NOT option ('NOCROSS ') THEN
askfilename(cross←name,cross←prot,cross←ppn,cross←dev,crossfileid,programname,false,fromtmp,brkchar);
%13
IF renewing and NOT option ('NONEW ') THEN
BEGIN
IF (new←name = ' ') AND (new←dev = 'DSK ') THEN
BEGIN
getstatus(oldsource, new←name,old←prot,old←ppn,old←dev);
new←name[7]:='N';
new←name[8]:='E';
new←name[9]:='W';
END;
startfile(newsource,new←name,new←prot,new←ppn,new←dev,false,newfileid,' ');
END;
\
IF NOT option('NOCROSS ') THEN
BEGIN
IF (cross←name = ' ') AND (cross←dev = 'DSK ') THEN
BEGIN
getstatus(oldsource, cross←name,old←prot,old←ppn,old←dev);
cross←name[7]:='l';
cross←name[8]:='s';
cross←name[9]:='t';
END;
startfile(crosslist,cross←name,cross←prot,cross←ppn,cross←dev,false,crossfileid,' ');
END;
%24
IF counting THEN
begin
writeln(tty);
writeln(tty,'i found ',countfilename:6,'.knt: will do statement counts');
end
else (*not counting*)
writeln(tty,countfilename:6,'.knt not found. normal cref');
break(tty);
\
getstatus(oldsource,old←name,old←prot,old←ppn,old←dev);
%13 renewing:= renewing and NOT option('NONEW '); \
crossing:= NOT option('NOCROSS ');
counting := counting and crossing;
IF crossing %4 and not counting \THEN
BEGIN
getoption('CROSS ',try);
IF try = 0 THEN
try:=15;
callnesting:=try > 7;
decnesting:=(try MOD 8) > 3;
refing:= (try MOD 4) > 1;
crossing:=(try MOD 2) = 1;
END;
IF option ('VERSION ') THEN
BEGIN
getoption ('VERSION ',goodversion);
IF goodversion > 9 THEN
BEGIN
goodversion := -1;
anyversion := true;
END;
END;
if option('width ') then
getoption('width ',maxch)
else
maxch := maxcrossch;
maxch := maxch - margin;
IF option('INDENT ') THEN
BEGIN
getoption('INDENT ',feed);
IF feed < 0 THEN
feed:=4;
END;
IF option('INCREMENT ') THEN
BEGIN
getoption('INCREMENT ',increment);
IF increment < 0 THEN
increment:= 100;
END;
dotting:=NOT option('NODOTS ');
IF option('BEGIN ') THEN
BEGIN
getoption('BEGIN ',indentbegin);
IF indentbegin < 0 THEN
BEGIN
begexd:=-indentbegin;
indentbegin:=0;
END;
END;
if option('lines ') then
getoption('lines ',maxline)
else
maxline := stdmaxline;
forcing:=forcing or option('FORCE ');
IF option('CASE ') THEN
BEGIN
setswitch('CASE ',rescase);
nonrcase:=rescase;
comcase:=rescase;
strcase:=rescase;
END;
setswitch('RES ',rescase);
setswitch('NONRES ',nonrcase);
setswitch('COMM ',comcase);
setswitch('STR ',strcase);
END (*get←directives*);
(*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
PROCEDURE header (name: alfa);
(*PRINT TOP OF FORM AND HEADER ON LIST OUTPUT*)
BEGIN (*HEADER*)
pagecnt2 := pagecnt2 + 1;
reallincnt := 0;
IF crossing THEN
BEGIN
IF firstpage THEN
firstpage := false
ELSE
page(crosslist);
%12
write(crosslist,version:28,' ':10,old←name:6,'.',old←name[7],old←name[8],old←name[9],
' [ ',prog←name,' ]',' ':9, date←text, ' ', time←text);
writeln (crosslist, 'PAGE ':15, pagecnt:3, '-', pagecnt2:2, name:15);
\
%3
write(crosslist,version:26,' ':7,old←name:6,'.',old←name[7],old←name[8],old←name[9],
' [ ',prog←name,' ] ', date←text, ' ', time←text);
writeln (crosslist, 'PAGE ':13, pagecnt:3, '-', pagecnt2:2, name:15);
\
%123 writeln(crosslist); \
END;
END (*HEADER*);
PROCEDURE newpage;
BEGIN (*NEWPAGE*)
pagecnt2 := 0;
pagecnt := pagecnt + 1;
%13
IF renewing THEN
if not firstpage then
page(newsource);
\
header (curprocname);
IF eoln (oldsource) THEN
readln(oldsource);
linecnt := 0;
line500 := 0;
IF prog←name <> blanks THEN
write(tty,pagecnt:3,'..');
break(tty);
END (*NEWPAGE*);
(*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
PROCEDURE block;
VAR
i: integer;
curproc : listptrty; (*ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)
itisaproc : boolean; (*TRUE WHEN THE WORD PROCEDURE IS FOUND*)
locprocstl: procstructy;
lastprocname: alfa; (*IMPLICIT STACK OF PROCEDURE NAMES FOR THE HEADER*)
PROCEDURE error (errnr : errkinds);
BEGIN (*ERROR*)
errcount := errcount+1;
IF crossing THEN
BEGIN
reallincnt := reallincnt + 1; (*COUNT THE LINE FOR THE ERROR MESSAGE ON CROSSLIST*)
write (crosslist, ' ':17,' *??* ');
CASE errnr OF
begerrinblkstr: write(crosslist, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit : write(crosslist, errmsg[errnr],emarknr : 4);
others : write(crosslist, errmsg[errnr]);
END;
writeln(crosslist,' *??*');
END;
writeln(tty);
write (tty, 'ERROR AT ', linecnt*increment: linnumsize, '/', pagecnt:2,': ');
CASE errnr OF
begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit : write(tty, errmsg[errnr],emarknr : 4);
others : write(tty, errmsg[errnr]);
END;
writeln(tty);
break (tty);
END (*ERROR*) ;
PROCEDURE writeline (position (*LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER*): integer);
VAR
i, j, maxchar: integer; (*MARKIERT ERSTES ZU DRUCKENDES ZEICHEN*)
PROCEDURE usedots(lastspaces: integer);
BEGIN (*USEDOTS*)
(*USE EITHER DOTS OR SPACES TO MAKE INDENTATION*)
IF lastspaces >= 0 THEN
IF dotting AND ((reallincnt MOD 5) = 0) THEN
write(crosslist,dots: lastspaces)
ELSE (*no dots in this line*)
BEGIN
lastspaces := lastspaces;
if lastspaces > 7 then
lastspaces := lastspaces + 2 + linnumsize;
write(crosslist, tabs: lastspaces DIV 8, ' ': lastspaces MOD 8);
END;
IF counting THEN (*if making statement counts, print the count*)
BEGIN
WHILE (sourcepage > countpage) DO (*find the count for this line*)
getcounts;
IF sourcepage = countpage THEN
WHILE sourceline > countline DO
getcounts;
IF (countline = sourceline) AND (countpage = sourcepage) and
not elsehere then
BEGIN (*if it exists, print it*)
write(crosslist,counttimes:countersize,'-+ ');
IF counttimes >= maxcounttimes THEN
BEGIN
maxcounttimes := counttimes;
maxcountline := sourceline;
maxcountpage := sourcepage;
END;
getcounts;
END
ELSE (*no count here*) (*otherwise, fill the space*)
IF dotting AND ((reallincnt MOD 5) = 0) THEN
if stmtpart then
write(crosslist,dots:countersize+1,'! ')
else
write(crosslist,dots:countersize+7,' ')
ELSE
if stmtpart then
write(crosslist,'!':countersize+2,' ':6)
else
write(crosslist,' ':countersize+8);
END (*counting*)
else (*not counting*)
write(crosslist,' ');
END (*USEDOTS*);
BEGIN (*WRITELINE*)
position := position - 2;
IF position > 0 THEN
BEGIN
i := buffmark + 1; (* 1. DISCARD BLANKS AT BOTH ENDS *)
WHILE (buffer [i] = ' ') AND (i <= position) DO
i := i + 1;
buffmark := position;
WHILE (buffer [position] = ' ') AND (i < position) DO
position := position - 1;
IF i <= position THEN (* 2. IF ANYTHING LEFT, WRITE IT. *)
BEGIN
IF NOT oldspaces THEN
lastspaces := spaces;
IF crossing THEN (* 2.1. WRITE THE LINE IN CROSSLIST *)
BEGIN
IF reallincnt >= maxline THEN
header (curprocname);
reallincnt := reallincnt + 1;
IF gotoinline THEN (* 2.1.1. LEFT MARGIN *)
BEGIN
write(crosslist, '***GOTO***');
gotoinline := false;
bmarktext:=' ';
emarktext:=' ';
END
ELSE
BEGIN
IF bmarktext <> ' ' THEN
BEGIN
write (crosslist, bmarktext, bmarknr : 3, ' ');
bmarktext := ' ';
END
ELSE
write(crosslist,' ');
IF emarktext <> ' ' THEN
BEGIN
write (crosslist,emarktext,emarknr : 3,' ');
emarktext := ' ';
END
ELSE
write (crosslist,' ');
END;
write (crosslist, linecnt * increment : linnumsize); (* 2.1.2. LINENUMBER AND INDENTATION *)
usedots(lastspaces);
maxchar:=maxch+i-lastspaces-1;
IF counting THEN
maxchar := maxchar - countersize+7;
FOR j := i TO position DO (* 2.1.3. CONTENTS OF THE LINE *)
BEGIN
IF j > maxchar THEN
BEGIN
writeln(crosslist);
IF reallincnt = maxline THEN
header (blanks);
reallincnt:=reallincnt+1;
write(crosslist,' ':margin);
usedots(spaces+feed-1);
maxchar:=maxch+j-lastspaces-1;
END;
crosslist↑ := buffer[j];
put(crosslist);
END;
writeln(crosslist);
END;
%13
IF renewing THEN (* 2.2. WRITE THE LINE IN NEWSOURCE *)
BEGIN
write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);
FOR j := i TO position DO
BEGIN
newsource↑ := buffer[j];
put(newsource);
END;
writeln(newsource);
END;
\
WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO (* 3. RESET POINTERS AND FLAGS *)
buffmark := buffmark + 1;
IF buffmark < bufflen THEN
IF buffer[buffmark - 1] = ' ' THEN
buffmark := buffmark - 1
ELSE
ELSE
IF (linenb = ' ') THEN
BEGIN
newpage;
sourcepage := sourcepage + 1;
sourceline := 0;
END
ELSE
IF (linecnt >= maxinc) THEN
newpage;
END (* IF I <= POSITION *);
END (* IF POSITION > 0 *);
lastspaces := spaces;
oldspaces := false;
thendo := false;
END (*WRITELINE*) ;
(*SCANNER:*) (*INSYMBOL[*) (*READBUFFER[*) (*readline]*) (*RESWORD*) (*FINDNAME*) (*insertcall*)
PROCEDURE insymbol ;
LABEL
1,111;
VAR
oldspacesmark, (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KOMMENTAREN*)
i: integer;
incondcomp: boolean;
PROCEDURE readbuffer;
(*READS A CHARACTER FROM THE INPUT BUFFER*)
PROCEDURE readline;
(*HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
(WITHOUT LEADING BLANKS) INTO BUFFER*)
VAR
ch : char;
i: integer;
BEGIN (*READLINE*)
(*ENTERED AT THE BEGINNING OF A LINE*)
LOOP
WHILE eoln (oldsource) AND NOT eof (oldsource) DO
BEGIN
(*IS THIS A PAGE MARK?*)
getlinenr (oldsource,linenb);
readln(oldsource);
IF linenb = ' ' THEN
BEGIN
newpage;
sourcepage := sourcepage + 1;
sourceline := 0;
END
ELSE (*HANDLE BLANK LINE*)
BEGIN
IF (linenb = '-----') AND counting THEN
sourceline := sourceline + 1;
line500 := line500 + 1;
linecnt := linecnt + 1;
if line500 = 500 then
begin
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
end;
IF crossing THEN
BEGIN
IF reallincnt = maxline THEN
header (curprocname);
reallincnt := reallincnt + 1;
writeln (crosslist, chr(ht),' ',linecnt * increment : linnumsize);
END;
%13
IF renewing THEN
writeln(newsource);
\
IF maxinc <= linecnt THEN
newpage;
END (*handle blank line*);
END (*while eoln(oldsource)...*);
EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
get(oldsource);
END (*loop*);
bufflen := 0;
(*READ IN THE LINE*)
WHILE NOT eoln (oldsource) DO
BEGIN
bufflen := bufflen + 1;
buffer [bufflen] := oldsource↑;
get(oldsource);
END;
if bufflen > 300 then
begin
error(linetoolong);
bufflen := 300;
end;
buffer[bufflen+1] := ' '; (*SO WE CAN ALWAYS BE ONE CHAR AHEAD*)
buffer[bufflen+2] := ' ';
IF NOT eof (oldsource) THEN
BEGIN
getlinenr (oldsource,linenb);
IF counting THEN
IF linenb = '-----' THEN
sourceline := sourceline + 1
ELSE
BEGIN
sourceline := 0;
FOR i := 1 TO 5 DO
sourceline := sourceline * 10 + ord(linenb[i]) - ord('0');
END;
linecnt := linecnt + 1;
line500 := line500 + 1;
if line500 = 500 then
begin
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
end;
readln(oldsource);
END;
bufferptr := 1;
buffmark := 0;
END (*READLINE*) ;
BEGIN (*READBUFFER*)
(*IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE*)
IF eoline THEN
BEGIN
%34 if not skipping then \
writeline (bufferptr);
ch := ' ';
IF eof (oldsource) THEN
eob := true
ELSE
readline;
END
ELSE
BEGIN
ch := buffer [bufferptr];
bufferptr := bufferptr + 1;
END;
eoline := bufferptr >= bufflen + 2;
END (*READBUFFER*) ;
FUNCTION resword: boolean ;
(*DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD*)
VAR
i,j: integer;
local: boolean;
BEGIN (*RESWORD*)
local:= false;
i := resnum[sy[1]];
WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
IF reslist[ i ] = sy THEN
BEGIN
local := true;
syty := ressy [i];
IF NOT rescase THEN
FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[j] := lower[buffer[j]];
END
ELSE
i := i + 1;
resword := local;
END (*RESWORD*) ;
PROCEDURE findname(curproc: listptrty);
VAR
lptr: listptrty; (*ZEIGER AUF DEN VORGAENGER IM BAUM*)
zptr : lineptrty; (*ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE*)
found, (*SET AFTER IDENTIFIER IS FOUND*)
right: boolean; (*MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM*)
indexch : char; (*INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)*)
BEGIN (*FINDNAME*)
indexch := sy [1];
listptr := firstname [indexch];
(*SEARCH IN THE TREE FOR THE IDENTIFIER*)
found := false;
WHILE NOT found AND (listptr <> NIL) DO
BEGIN
lptr:= listptr;
IF sy = listptr↑.name THEN
BEGIN
found := true;
IF (listptr↑.profunflag IN ['P', 'F']) AND (NOT declaring) THEN
IF locprocstl↑.proclevel + 1 >= listptr↑.procdata↑.proclevel THEN
BEGIN
new (workcall);
workcall↑.whom := listptr↑.procdata;
workcall↑.nextcall := NIL;
END;
zptr := listptr↑.last;
IF (zptr↑.linenr <> linecnt+1) OR (zptr↑.pagenr <> pagecnt) THEN
BEGIN
new (listptr↑.last);
WITH listptr↑.last↑ DO
BEGIN
linenr := linecnt + 1;
pagenr := pagecnt;
contlink := NIL;
IF declaring THEN
declflag := 'D'
ELSE
declflag := ' ';
END;
zptr↑.contlink := listptr↑.last;
END
ELSE
zptr↑.declflag := 'M';
END
ELSE
IF sy > listptr↑.name THEN
BEGIN
listptr:= listptr↑.rlink;
right:= true;
END
ELSE
BEGIN
listptr:= listptr↑.llink;
right:= false;
END;
END;
IF NOT found THEN
BEGIN (*UNKNOWN IDENTIFIER*)
new (listptr);
WITH listptr↑ DO
BEGIN
name := sy;
llink := NIL;
rlink := NIL;
profunflag := ' ';
externflag := ' ';
procdata := NIL;
END;
IF firstname [indexch] = NIL THEN
firstname [indexch] := listptr
ELSE
IF right THEN
lptr↑.rlink := listptr
ELSE
lptr↑.llink := listptr;
WITH listptr↑ DO
BEGIN
new (first);
WITH first↑ DO
BEGIN
linenr := linecnt + 1;
pagenr := pagecnt;
contlink := NIL;
IF declaring THEN
declflag := 'D'
ELSE
declflag := ' ';
END;
last := first ;
END;
END;
END (*FINDNAME*) ;
PROCEDURE insertcall;
VAR
lastcall,
thiscall: calledty;
repeated : boolean; (*SET IF SY IS A PROC-NAME AND IS ALREADY IN THE CALL SEQUENCE*)
BEGIN (*INSERTCALL*)
IF locprocstl↑.firstcall = NIL THEN
locprocstl↑.firstcall := workcall
ELSE
BEGIN
thiscall := locprocstl↑.firstcall;
repeated := false;
WHILE (thiscall <> NIL) AND NOT repeated DO
IF thiscall↑.whom↑.procname↑.name = workcall↑.whom↑.procname↑.name THEN
repeated := true
ELSE
BEGIN
lastcall := thiscall;
thiscall := thiscall↑.nextcall;
END;
IF NOT repeated THEN
lastcall↑.nextcall := workcall;
END;
workcall := NIL;
END (*INSERTCALL*);
(*parenthese*) (*docomment[*) (*options]*) (*skip_e_directory*)
PROCEDURE parenthese (which: symbol);
(*HANDLES THE FORMATTING OF PARENTHESES, EXCEPT THOSE IN VARIANT PARTS OF RECORDS*)
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN*)
BEGIN (*PARENTHESE*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := lastspaces + bufferptr - buffmark - 2;
(*SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION*)
IF declaring THEN
REPEAT
insymbol;
CASE syty OF
colon: declaring := false;
semicolon: declaring := true;
END;
UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy]
ELSE
REPEAT
insymbol;
UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = which THEN
insymbol
else
if which = rparent then
error(missgrpar)
else
error(missgrbrack);
END (*PARENTHESE*) ;
PROCEDURE docomment (dellength: integer; firstch: char);
var
lcondcomp: boolean;
PROCEDURE options;
(*processes the options inside a comment that starts with
a dollar sign.*)
VAR
lch : char;
i: integer;
lname: packed array[1..5] of char;
BEGIN (*OPTIONS*)
REPEAT
readbuffer; lch := ch;
IF ch <> firstch THEN readbuffer;
if lch in ['=','#'] then
begin
i := 1;
lname := ' ';
while ch in (alphanum + ['_']) do
begin
if i <= 4 then
lname[i] := ch;
readbuffer;
i := i + 1;
end;
if i in [2..5] then
if lch = '=' then
if not programpresent then
nameversion := lname
else
error(illversion)
else (*lch = '#'*)
begin
if lname = nameversion then
begin
lcondcomp := true;
whichcond := firstch;
end
end
else (*no name, or too long*)
error(illversion);
end (*ch in ['=','*'] *);
until ch <> ',';
end (*options*);
BEGIN (* DOCOMMENT *)
oldspacesmark := spaces;
IF oldspaces THEN
spaces := lastspaces
ELSE
lastspaces := spaces;
spaces := spaces + bufferptr - 2;
oldspaces := true;
lcondcomp := false;
if ch = '$' then
options;
incondcomp := incondcomp or lcondcomp;
if not lcondcomp then
IF dellength = 2 THEN
REPEAT
if not comcase then
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
UNTIL (ch = ')') AND (buffer[bufferptr-2] = '*') OR eob
ELSE
REPEAT
if not comcase then
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
UNTIL (ch = firstch) OR eob;
REPEAT
readbuffer;
UNTIL ch <> ' ';
spaces := oldspacesmark;
END (*DOCOMMENT*);
%34
PROCEDURE skip_e_directory;
BEGIN (*SKIP_E_DIRECTORY*)
skipping := true;
while not eoln(oldsource) do
readbuffer;
skipping := false;
END (*SKIP_E_DIRECTORY*);
\
(*
PROCEDURE skip_e_directory;
BEGIN (*SKIP_E_DIRECTORY*)(*
WHILE NOT (oldsource↑ = ';') DO
BEGIN
IF eoln(oldsource) THEN
linecnt := linecnt + 1;
get(oldsource);
END;
get(oldsource);
get(oldsource);
linecnt :=linecnt + 2;
bufferptr := 0;
eoline := true;
firstpage := true;
END (*SKIP_E_DIRECTORY*)(* ;
\
*)
(*] INSYMBOL*)
BEGIN (*INSYMBOL*)
prevsyty := syty;
111:
syleng := 0;
WHILE (ch IN ['_','(',' ','$','?','@','%','\', %12 '!' \ %34 '"' \ ]) AND NOT eob DO
CASE ch OF
'(':
begin
readbuffer;
IF (ch = '*') THEN
docomment (2,'*')
ELSE
begin
syty := lparent;
if variant←level = 0 then
parenthese(rparent);
goto 1;
end;
end;
'%':
begin
incondcomp := false;
readbuffer;
if not anyversion then
while ch in digits do
begin
if ord(ch) - ord('0') = goodversion then
incondcomp := true;
readbuffer;
end;
if incondcomp or anyversion then
BEGIN
readbuffer;
END
ELSE
docomment (1,'\');
end;
%34
'"':
begin
readbuffer;
IF incondcomp and (whichcond = '"') THEN
incondcomp := false
else
docomment(1,'"');
end;
\
OTHERS:
readbuffer;
END;
CASE ch OF
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z':
BEGIN
syleng := 0;
sy := ' ';
REPEAT
syleng := syleng + 1;
IF syleng <= 10 THEN
sy [syleng] := ch;
readbuffer;
UNTIL NOT (ch IN (alphanum + ['←']));
%34
if firstpage and (sy = 'comment ') then
begin
skip_e_directory;
goto 111;
end
else
\
IF NOT resword THEN
BEGIN
syty := ident ;
findname(curproc);
IF NOT nonrcase THEN
FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[i] := lower[buffer[i]];
END
END;
'0', '1', '2', '3', '4', '5', '6', '7', '8',
'9':
BEGIN
REPEAT
syleng := syleng + 1;
readbuffer;
UNTIL NOT (ch IN digits);
syty := intconst;
IF ch = 'B' THEN
readbuffer
ELSE
BEGIN
IF ch = '.' THEN
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN digits);
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
IF ch = 'E' THEN
BEGIN
readbuffer;
IF ch IN ['+','-'] THEN
readbuffer;
WHILE ch IN digits DO
readbuffer;
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
END;
END;
'''':
BEGIN
syty := strgconst;
REPEAT
readbuffer;
UNTIL (ch = '''') OR eob OR eoline;
IF ch <> '''' THEN
error(missgquote);
readbuffer;
END;
%12 '"': \
%34 '!': \
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN (digits + ['A'..'F']));
syty := intconst;
END;
' ': syty := eobsy; (*END OF FILE*)
':': BEGIN
readbuffer;
if ch = '=' then
begin
workcall := NIL;
syty := othersy;
readbuffer;
END
else
syty := delsy[':'];
end;
'\':
begin
readbuffer;
IF incondcomp and (whichcond = '\') THEN
BEGIN
incondcomp := false;
GOTO 111;
END
else
syty := othersy;
end;
'*':
begin
readbuffer;
IF incondcomp and (whichcond = '*') THEN
if ch = ')' then
begin
incondcomp := false;
readbuffer;
GOTO 111;
end
else
syty := othersy;
end;
'[':
begin
syty := lbracket; readbuffer; parenthese(rbracket);
end;
OTHERS:
BEGIN
syty := delsy [ch];
readbuffer;
END
END (*case ch of*);
1:
IF workcall <> NIL THEN
insertcall;
END (*INSYMBOL*) ;
(*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
PROCEDURE recdef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)
PROCEDURE casedef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)
PROCEDURE parenthese;
(*HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS*)
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*PARENTHESE*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := spaces + bufferptr - 2;
declaring := true;
insymbol;
REPEAT
CASE syty OF
casesy :
casedef;
recordsy :
recdef;
semicolon, lparent:
BEGIN
declaring := true;
insymbol;
END;
eqlsy, colon:
BEGIN
declaring := false;
insymbol;
END;
OTHERS :
insymbol;
END;
(*UNTIL WE APPARENTLY LEAVE THE DECLARATION*)
UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
loopsy..ifsy,forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = rparent THEN
BEGIN
declaring := true;
insymbol;
END
ELSE
error(missgrpar);
END (*PARENTHESE*) ;
BEGIN (*CASEDEF*)
variant←level := variant←level+1;
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + lastspaces - syleng + 3;
declaring := true;
insymbol;
declaring := false;
REPEAT
IF syty = lparent THEN
parenthese
ELSE
insymbol
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
spaces := oldspacesmark;
variant←level := variant←level-1;
END (*CASEDEF*) ;
BEGIN (*RECDEF*)
oldspacesmark := spaces;
oldspaces := true;
lastspaces := spaces;
spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
declaring := true;
insymbol;
REPEAT
CASE syty OF
casesy : casedef;
recordsy : recdef;
semicolon, lparent:
BEGIN
declaring := true;
insymbol;
END;
eqlsy, colon:
BEGIN
declaring := false;
insymbol;
END;
endsy:;
OTHERS : insymbol
END;
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
oldspaces := true;
lastspaces := spaces - feed;
spaces := oldspacesmark;
IF syty = endsy THEN
BEGIN
declaring := true;
insymbol;
END
ELSE
error(missgend);
END (*RECDEF*) ;
(*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
PROCEDURE statement;
VAR
oldspacesmark, (*SPACES AT ENTRY OF THIS PROCEDURE*)
curblocknr : integer; (*CURRENT BLOCKNUMBER*)
PROCEDURE endedstatseq(endsym: symbol; letter: char);
BEGIN
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
BEGIN
error(missgend);
IF NOT (syty IN begsym) THEN
insymbol;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
END;
IF forcing THEN
writeline(bufferptr-syleng);
emarktext := letter;
emarknr := curblocknr;
oldspaces := true;
IF (endsym = endsy) THEN
begin
IF indentbegin = 0 THEN
lastspaces := max(0,spaces-begexd)
ELSE
lastspaces := max(0,spaces-indentbegin);
if syty <> endsy then
error(missgend)
end
ELSE
begin
lastspaces := max(0,spaces - feed);
IF syty <> endsym THEN
error(missguntil);
end;
END (*ENDEDSTATSEQ*);
PROCEDURE compstat;
BEGIN (*COMPSTAT*)
IF indentbegin = 0 THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-begexd)
END;
END
ELSE
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - indentbegin);
END;
bmarktext := 'B';
marksyty := prevsyty;
insymbol;
IF forcing THEN
begin
if marksyty = othersy then
elsehere := true;
writeline(bufferptr-syleng);
elsehere := false;
end;
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END;
END (*COMPSTAT*) ;
PROCEDURE casestat;
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*CASESTAT*)
bmarktext := 'C';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
insymbol;
statement;
IF syty = ofsy THEN
writeline (bufferptr)
ELSE
error (missgof);
LOOP
REPEAT
REPEAT
insymbol;
UNTIL syty IN [colon, functionsy .. eobsy];
IF syty = colon THEN
BEGIN
oldspacesmark := spaces;
lastspaces := spaces;
%34 spaces := spaces + feed; \
%12 spaces := bufferptr - buffmark + spaces - 4; \
oldspaces := true;
thendo := true;
insymbol;
statement;
IF syty = semicolon THEN
insymbol;
spaces := oldspacesmark;
END;
UNTIL syty IN endsym;
EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
error (missgend);
END;
writeline(bufferptr-syleng);
emarktext := 'E';
emarknr := curblocknr;
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END
ELSE
error (missgend);
END (*CASESTAT*) ;
PROCEDURE loopstat;
BEGIN (*LOOPSTAT*)
bmarktext := 'L';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
marksyty := prevsyty;
insymbol;
if not (marksyty in openblocksym) then
elsehere := true;
writeline(bufferptr-syleng);
elsehere := false;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
IF syty = exitsy THEN
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := spaces-feed;
emarktext := 'X';
emarknr := curblocknr;
insymbol; insymbol;
prevsyty := exitsy;
END
ELSE
error(missgexit);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END;
END (*LOOPSTAT*) ;
PROCEDURE ifstat;
VAR
oldspacesmark: integer;
BEGIN (*IFSTAT*)
marksyty := prevsyty;
oldspacesmark := spaces;
bmarktext := 'I';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE*)
spaces := lastspaces + bufferptr - buffmark + feed - 4;
insymbol;
statement; (*WILL EAT THE EXPRESSION AND STOP ON A KEYWORD*)
IF syty = thensy THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
emarktext := 'T';
emarknr := curblocknr;
IF forcing THEN
begin
if not (marksyty in openblocksym) then
elsehere := true;
writeline(bufferptr);
elsehere :=false;
end
ELSE
thendo := true;
(*SUPPRESS FURTHER INDENTATION FROM A 'DO'*)
insymbol;
statement;
END
ELSE
error (missgthen);
IF syty = elsesy THEN (*parse the else part*)
BEGIN
writeline(bufferptr-syleng);
emarktext := 'S';
emarknr := curblocknr;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
IF forcing THEN
begin
elsehere := true;
writeline(bufferptr);
elsehere := false;
end
ELSE
thendo := true;
insymbol;
statement;
END;
oldspaces := true; (*PRESERVE INDENTATION OF STATEMENT*)
writeline(bufferptr-syleng);
spaces := oldspacesmark;
END (*IFSTAT*) ;
PROCEDURE labelstat;
BEGIN (*LABELSTAT*)
lastspaces := level * feed;
oldspaces := true;
insymbol;
elsehere := true;
writeline(bufferptr-syleng);
elsehere := false;
END (*LABELSTAT*) ;
PROCEDURE repeatstat;
BEGIN
bmarktext := 'R';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
marksyty :=prevsyty;
insymbol;
if not (marksyty in openblocksym) then
elsehere := true;
endedstatseq(untilsy, 'U');
IF syty = untilsy THEN
BEGIN
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END (*REPEATSTAT*) ;
BEGIN (*STATEMENT*)
oldspacesmark := spaces; (*SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE IT*)
IF syty = intconst THEN
BEGIN
insymbol;
IF syty = colon THEN
labelstat;
END;
IF syty IN begsym THEN
BEGIN
blocknr := (blocknr + 1) MOD 1000;
curblocknr := blocknr;
bmarknr := curblocknr;
IF NOT thendo THEN
BEGIN
writeline(bufferptr-syleng);
elsehere := false;
IF (syty <> beginsy) THEN
spaces := spaces + feed
ELSE
spaces:=spaces + indentbegin;
END;
CASE syty OF
beginsy : compstat;
loopsy : loopstat;
casesy : casestat;
ifsy : ifstat;
repeatsy: repeatstat
END;
END
ELSE
BEGIN
IF forcing THEN
IF syty IN [forsy,whilesy] THEN
writeline(bufferptr-syleng);
IF syty = gotosy THEN
gotoinline:=true;
WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
insymbol;
IF syty = dosy THEN
BEGIN
IF NOT thendo THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
spaces := spaces + feed;
IF NOT forcing THEN
thendo := true;
END;
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END;
spaces := oldspacesmark;
END (*STATEMENT*) ;
(*]BLOCK*)
BEGIN (*BLOCK*)
stmtpart := false;
declaring := true;
REPEAT
insymbol;
UNTIL syty IN relevantsym;
level := level + 1;
curproc := listptr;
spaces := level * feed;
(*HANDLE NESTING LIST*)
locprocstl := procstrucf;
WITH procstrucdata, item, procname↑ DO
IF exists THEN
BEGIN
IF procdata <> NIL THEN
BEGIN
IF externflag = 'F' THEN
procdata := NIL
ELSE
IF externflag = ' ' THEN
externflag := 'D';
locprocstl := procdata;
END;
IF procdata = NIL THEN
BEGIN
IF (syty IN [forwardsy,externsy]) THEN
IF syty = externsy THEN
externflag := 'E'
ELSE
externflag := 'F';
new(procstrucl↑.nextproc);
procstrucl := procstrucl↑.nextproc;
procdata := procstrucl;
procstrucl↑ := item;
locprocstl := procstrucl;
END;
procstrucdata.exists := false
END;
REPEAT
fwddecl := false;
WHILE syty IN decsym DO (*declarations: labels, types, vars*)
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty = programsy THEN
BEGIN
programpresent := true;
insymbol;
prog←name := sy;
procstrucf↑.procname := listptr;
listptr↑.procdata := procstrucf;
listptr↑.profunflag := 'M';
writeln(tty);
write(tty,version:verlength,': ',old←name:6,' [ ',prog←name,' ] PAGE');
FOR i := 1 TO pagecnt DO
write (tty, i:3,'..');
break(tty);
declaring := false;
END
ELSE (*syty <> programsy*)
BEGIN
declaring := true;
IF forcing THEN
writeline(bufferptr);
END;
REPEAT
insymbol;
CASE syty OF
semicolon, lparent : declaring := true;
eqlsy, colon : declaring := false;
recordsy: recdef;
END;
UNTIL syty IN relevantsym;
END;
declaring := false;
WHILE syty IN prosym DO (*procedure and function declarations*)
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
lastprocname := curprocname;
IF syty <> initprocsy THEN
BEGIN
itisaproc := syty = proceduresy;
declaring := true;
insymbol;
curprocname := listptr↑.name;
IF itisaproc THEN
listptr↑.profunflag := 'P'
ELSE
listptr↑.profunflag := 'F';
WITH procstrucdata, item DO
BEGIN
exists := true;
procname := listptr;
nextproc := NIL;
linenr := linecnt+1;
pagenr := pagecnt;
proclevel := level;
printed := false;
firstcall := NIL;
END;
END
ELSE
curprocname := 'INITPROCED';
block;
curprocname := lastprocname;
declaring := false;
stmtpart := false;
IF syty = semicolon THEN
insymbol;
END (*while syty in prosym*)
(*FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.*)
UNTIL NOT fwddecl;
IF forcing THEN
writeline(bufferptr-syleng);
level := level - 1;
spaces := level * feed;
IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
BEGIN
IF (level = 0) AND (syty = point) THEN
nobody := true
ELSE
error (begerrinblkstr);
WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
insymbol
END;
IF syty = beginsy THEN
BEGIN
countline := sourceline; (*to get the count in the line of the begin*)
countpage := sourcepage;
declaring := false;
stmtpart := true; (*to prevent bars in declarations*)
locprocstl↑.begline := linecnt + 1;
locprocstl↑.begpage := pagecnt;
statement;
locprocstl↑.endline := linecnt + 1;
locprocstl↑.endpage := pagecnt;
END
ELSE
IF NOT nobody THEN
BEGIN
fwddecl := true;
insymbol;
END;
IF level = 0 THEN
if programpresent then
BEGIN
IF nobody THEN
BEGIN
error (missgmain);
errcount := errcount - 1;
END;
IF syty <> point THEN
BEGIN
error(missgpoint);
REPEAT (*SKIP TEXT UNTIL END OF FILE OR END OF PROGRAM HIT*)
REPEAT
insymbol
UNTIL (syty = endsy) OR (syty = eobsy);
IF syty = endsy THEN
insymbol;
UNTIL (syty = point) OR (syty = eobsy);
END;
writeline(bufflen+2);
writeln(tty);
writeln (tty,errcount:4,' ERROR(S) DETECTED'); break(tty);
END (*if level = 0*);
END (*BLOCK*) ;
(*PRINT←XREF←LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
PROCEDURE print←xref←list;
VAR
pred : listptrty;
indexch : char; (*LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN*)
listpgnr : boolean; (*TRUE IF THE SOURCE CONTAINS A PAGE MARK*)
itemlen: integer; (*LENGTH OF A PRINTED LINENUMBER, 9 OR 12*)
thiscall : calledty;
oldcrossing: boolean;
PROCEDURE checkpage(heading: boolean);
BEGIN
IF reallincnt = maxline THEN
BEGIN
IF heading THEN
header (listptr↑.name)
ELSE
header (blanks);
END;
reallincnt:=reallincnt+1;
END(*CHECKPAGE*);
PROCEDURE writeprocname (procstrucl: procstructy; depth: integer; mark: char; numbering: boolean);
BEGIN (*WRITEPROCNAME*)
writeln(crosslist);
checkpage(false);
WITH procstrucl↑, procname↑ DO
BEGIN
IF numbering THEN
write (crosslist, linecnt * increment:linnumsize+1, ' ');
IF depth > 2 THEN
write (crosslist, '. ',dots:depth-1)
ELSE
write (crosslist, '.':depth+1);
write (crosslist, name : 10, ' (', profunflag, ')',
mark:2, externflag:2, chr(ht), linenr * increment : 8);
IF listpgnr OR (pagenr > 1) THEN
write(crosslist, '/',pagenr : 2);
IF (mark = ' ') AND NOT (externflag IN ['E', 'F']) THEN
BEGIN
write (crosslist, begline * increment: linnumsize + 3);
IF listpgnr THEN
write (crosslist, '/', begpage: 2);
write (crosslist, endline * increment: linnumsize + 3);
IF listpgnr THEN
write (crosslist, '/', endpage:2);
END
ELSE
IF externflag = 'F' THEN
externflag := ' ';
END;
END (*WRITEPROCNAME*);
PROCEDURE writelinenr (spaces : integer);
VAR
link : lineptrty; (*ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN*)
maxcnt, (*MAXIMUM ALLOWABLE VALUE OF COUNT*)
count : integer; (*ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE*)
BEGIN (*WRITELINENR*)
count := 0;
maxcnt := (maxcrossch + 1 - spaces) DIV itemlen; (*ITEMS ARE ITEMLEN CHARS EACH*)
link := listptr↑.first;
REPEAT
IF count = maxcnt THEN
BEGIN
writeln(crosslist);
checkpage(true);
write (crosslist, ' ' : spaces);
count := 0;
END;
count := count + 1;
WITH link↑ DO
BEGIN
write (crosslist, linenr * increment : linnumsize + 1);
IF listpgnr THEN
write(crosslist, '/',pagenr : 2);
write (crosslist,declflag);
link := contlink;
END;
UNTIL link = NIL;
END (*WRITELINENR*) ;
PROCEDURE dumpcall (thisproc: procstructy; depth: integer);
VAR
thiscall: calledty;
BEGIN (*DUMPCALL*)
linecnt := linecnt + 1;
WITH thisproc↑ DO
IF printed THEN
writeprocname (thisproc, depth,'*', true)
ELSE
BEGIN
writeprocname (thisproc, depth, ' ', true);
printed := true;
linenr := linecnt;
pagenr := pagecnt;
thiscall := firstcall;
WHILE thiscall <> NIL DO
BEGIN
dumpcall (thiscall↑.whom, depth + feed);
thiscall := thiscall↑.nextcall;
END;
END;
END (*DUMPCALL*);
BEGIN (*PRINT←XREF←LIST*)
oldcrossing := crossing;
crossing := true;
listpgnr := pagecnt > 1;
itemlen := linnumsize + 2;
IF listpgnr THEN
itemlen := itemlen + 3;
WITH firstname ['M']↑ DO (*DELETE 'MAIN'*)
IF rlink = NIL THEN
firstname ['M'] := llink
ELSE
BEGIN
listptr := rlink;
WHILE listptr↑.llink <> NIL DO
listptr := listptr↑.llink;
listptr↑.llink := llink;
firstname ['M'] := rlink;
END;
indexch := 'A';
WHILE (indexch < 'Z') AND (firstname [indexch] = NIL) DO
indexch := succ (indexch);
IF firstname [indexch] <> NIL THEN
BEGIN
IF refing THEN
BEGIN
pagecnt := pagecnt + 1;
pagecnt2 := 0;
header (blanks);
writeln (crosslist, 'CROSS REFERENCE LISTING OF IDENTIFIERS');
writeln (crosslist, '**************************************');
write(tty,'CROSS REFERENCE..'); break;
reallincnt:= reallincnt + 3;
FOR indexch := indexch TO 'Z' DO
WHILE firstname [indexch] <> NIL DO
BEGIN
listptr := firstname [indexch];
WHILE listptr↑.llink <> NIL DO
BEGIN
pred := listptr;
listptr := listptr↑.llink;
END;
IF listptr = firstname [indexch] THEN
firstname [indexch] := listptr↑.rlink
ELSE
pred↑.llink := listptr↑.rlink;
writeln(crosslist);
checkpage(true);
write (crosslist, listptr↑.profunflag, listptr↑.name : 11);
writelinenr (12);
END;
END;
IF procstrucl <> procstrucf THEN
BEGIN
IF decnesting THEN
BEGIN
pagecnt := pagecnt + 1;
pagecnt2 := 0;
writeln (crosslist);
header ('*DECLARAT*');
writeln (crosslist, 'NESTING OF PROCEDURE-FUNCTION DECLARATION');
writeln (crosslist, '*****************************************');
writeln (crosslist, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
write(tty,' PROCEDURE DECLARATIONS..'); break;
reallincnt:= reallincnt + 4;
procstrucl := procstrucf;
REPEAT
writeprocname (procstrucl, procstrucl↑.proclevel * 4, ' ', false);
procstrucl := procstrucl↑.nextproc;
UNTIL procstrucl = NIL;
END;
IF callnesting THEN
BEGIN
pagecnt := pagecnt + 1;
pagecnt2 := 0;
writeln (crosslist);
header ('* CALLS * ');
writeln (crosslist, 'NESTING OF PROCEDURE-FUNCTION CALLS');
writeln (crosslist, '***********************************');
writeln (crosslist, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
write(tty,' PROCEDURE CALLS..'); break;
reallincnt := reallincnt + 4;
linecnt := 0;
procstrucl := procstrucf;
WHILE procstrucl <> NIL DO
BEGIN
IF NOT procstrucl↑.printed THEN
dumpcall (procstrucl, 0);
procstrucl := procstrucl↑.nextproc;
END;
END;
END;
END;
crossing := oldcrossing;
END (*PRINT←XREF←LIST*) ;
(*MAIN PROGRAM*)
BEGIN
settime;
get←directives;
initialize;
(*FIND MAX POSSIBLE LINE NUMBER WITH THIS INCREMENT*)
%12
maxinc := (99999 DIV increment);
IF maxinc > 4000 THEN
maxinc := 4000;
\
%34
maxinc := (1000 div increment);
\
LOOP
block;
EXIT IF NOT programpresent OR (syty = eobsy);
IF counting THEN
BEGIN
writeln(tty);
writeln(tty,'MAXIMUM COUNT: ',maxcounttimes,' AT LINE ',maxcountline*increment:5,'/',maxcountpage:2);
IF crossing THEN
BEGIN
writeln(crosslist);
writeln(crosslist,'MAXIMUM COUNT: ',maxcounttimes,' AT LINE ',maxcountline*increment:5,'/',maxcountpage:2);
END;
END;
IF refing OR decnesting OR callnesting THEN
print←xref←list;
dispose(heapmark); (*RELEASE THE ENTIRE HEAP*)
reinitialize;
END;
if counting then
rewrite(countfile);
timereport(ttyoutput, ' ');
getnextcall (link←name, link←device);
IF link←name <> ' ' THEN
call (link←name, link←device);
END (*PCROSS*).